unit CPInstructions;

interface

uses Classes, CPParserBase, CPToken, CPBuiltinFunctions, Contnrs;

type
  TCPInstructionKind = (tiNumber, tiVariable, tiBuiltinFunction, tiOperator);

  { Defines all possible bytecode instructions. }
  TCPBytecodeInstruction = record
    Kind: TCPInstructionKind;
    case TCPInstructionKind of
      tiNumber:
        (Value: Double);
      tiVariable:
        (Variable: TObject);
      tiBuiltinFunction:
        (BuiltinFunction: TCPBuiltinFunction;
         ArgumentCount: Integer);
      tiOperator:
        (Operation: TCPOperation);
  end;

  PCPBytecodeInstruction = ^TCPBytecodeInstruction;

const
  { Size of a single instruction in Bytes }
  CPInstructionSize = SizeOf(TCPBytecodeInstruction);

type
  { Stores a parsed mathematical term as a set of instructions that can be
    evaluated to a numeric value. }
  TCPInstructionList = class
  private
    { Bytecode containing the instructions }
    FBytecode: array of Byte;
    { Pointer that points at the first byte after the last added instruction. }
    FInstruction: PCPBytecodeInstruction;
    { List of variables referenced by this instruction list }
    FVariables: TObjectList;
    { A stack with at least this number of elements is needed to evaluate
      this instruction list. }
    FMaxStackCount: Integer;
    { Stack that is used for evaluation }
    FStack: TCPEvaluationStack;
    procedure AddVariable(Parser: TObject; Token: TCPIdentifierToken);
    procedure AddBuiltinFunction(Parser: TObject; Token: TCPIdentifierToken);
    procedure AddOperator(Operator: PCPOperator);
    procedure AddNumber(Value: Double);
    { Resizes the byte code array, if it can not hold another instruction }
    procedure Resize;
    { Resizes the evaluation stack if it can not handle the evaluation of
      the instruciton list. }
    procedure ResizeStack;
    { Trims the length of the byte code array to the size of its insturctions }
    procedure AdjustSize;
    { Determines the maximum stack size needed to evaluate this instruction
      list }
    procedure Validate;
    procedure SetStack(const Value: TCPEvaluationStack);
  public
    { Creates a new instruciton list.
      @param Empty If Empty is true, the instruciton list will be empty and
      cannot be evaluated; otherwise, if Empty is false the instruction list
      will contain a number (with NaN as value) as instruction }
    constructor Create(Empty: Boolean = true);
    destructor Destroy; override;
{$IFDEF DEBUG}
    { Dumps all bytecode instructions on the standard out }
    procedure DumpBytecode;
{$ENDIF}
    { Prepares the instruction list for evaluation. This method has to be called
      after all instructions have been added. }
    procedure Finish;
    { Adds the specified token as a new instruction to the instruction list.
      A pointer to the resulting instruction is returned.
      @param Parser Parser instance holding variables and built-in functions
      @param Token Token that is parsed and converted to an instruciton.
      @return Pointer to created instruciton }
    function AddToken(Parser: TObject; Token: TCPToken): PCPBytecodeInstruction;
    { Evaluates the instruction list to a numeric value and returns it }
    function Evaluate: TCPFloat;
    { Gets the list of all variables used in this instruction list }
    property Variables: TObjectList read FVariables;
    { Gets the number of elements that is needed for a evaluation stack to
      evaluate this instruciton list }
    property MaxStackCount: Integer read FMaxStackCount;
    { Gets or sets the evaluation stack. If a stack is set it needs to have
      at least MaxStackCount elements. }
    property Stack: TCPEvaluationStack read FStack write SetStack;
  end;

  { Represents a mathematical term that is given as a expression string and
    can be evaluated to number }
  TCPTerm = class
  private
    procedure SetInstructions(const Value: TCPInstructionList);
  protected
    { Parser instance used for parsing the string expression }
    FParser: TObject;
    { Expresion string that defines the mathematical term }
    FExpression: string;
    { Instruction list with bytecode that is generated by the parser }
    FInstructions: TCPInstructionList;
    { Error that was caused by the last parsing of the term }
    FExpressionError: TCPExpressionError;
    { Sets the expression string and starts parsing it }
    procedure SetExpression(const Value: string); virtual;
  public
    { Creates a new term instance.
      @param Parser Parser instance used for parsing the string expression }
    constructor Create(Parser: TObject); overload;
    { Creates a new term instance.
      @param Parser Parser instance used for parsing the string expression
      @param Expression The term is initialized with this expression }
    constructor Create(Parser: TObject; Expression: string); overload;
    destructor Destroy; override;
    { Assigns the specified error to this term and marks it as evaluatable. }
    procedure SetError(ExpressionError: TCPExpressionError);
    { Gets or sets the expression string of this term. Setting a new expression
      string will parse the expression and generate an instruciton list that
      can be evaluated. }
    property Expression: string read FExpression write SetExpression;
    { Gets the instruction list of this term }
    property Instructions: TCPInstructionList read FInstructions write
      SetInstructions;
    { Returns the error that was caused by the last parsing of the term's
      expression or was set by a previous SetError() call. }
    property Error: TCPExpressionError read FExpressionError;
  end;

implementation

uses SysUtils, Math, CPParser, CPVariables;

var
  CPStack: TCPEvaluationStack;
  { TODO: Possible future problem: Shared stack prohibits multi-threaded evaluaiton }

procedure TCPInstructionList.Resize;
var
  Index: Integer;
begin
  Index := Cardinal(FInstruction) - Cardinal(@FBytecode[0]);
  { If the bytecode array cannot hold one more instruction, then double its
    size: }
  if (Index + SizeOf(TCPBytecodeInstruction)) >= Length(FBytecode) then
  begin
    SetLength(FBytecode, Length(FBytecode) shl 1);
    FInstruction := @FBytecode[Index];
  end;
end;

procedure TCPInstructionList.ResizeStack;
begin
  if (Length(FStack) < FMaxStackCount) then
    SetLength(FStack, Max(FMaxStackCount, CPDefaultStackCount));
end;

procedure TCPInstructionList.SetStack(const Value: TCPEvaluationStack);
begin
  if Value = nil then
    raise EInvalidArgument.Create
      (Format('Stack may not be nil.', [FMaxStackCount]));
  // Finalize previous stack:
  if FStack <> nil then
    Finalize(FStack);
  FStack := Value;
  { Ensure stack is big enough for evaluating this instruction list: }
  ResizeStack;
end;

procedure TCPInstructionList.Validate;
var
  Instruction: PCPBytecodeInstruction;
  LastInstruction: Cardinal;
  StackCount: Integer;
begin
  Instruction := Pointer(FBytecode);
  LastInstruction := Cardinal(Instruction) + Cardinal(Length(FBytecode))
    - CPInstructionSize;
  StackCount := 0;
  // Iterate through instructions to determine stack usage:
  while Cardinal(Instruction) <= LastInstruction do
  begin
    case TCPInstructionKind(Instruction.Kind) of
      tiNumber, tiVariable:
        Inc(StackCount);
      tiBuiltinFunction:
        Dec(StackCount, Instruction.ArgumentCount - 1);
      tiOperator:
        Dec(StackCount, CPOperators[Instruction.Operation].Arity - 1);
    end;
    // Calculate peek of stack usage:
    FMaxStackCount := Max(FMaxStackCount, StackCount);
    if StackCount < 0 then
      raise EInvalidOperation.Create('Stack underrun'); // Stack underrun, should never happen
    Inc(Cardinal(Instruction), CPInstructionSize);
  end;
  // Ensure a big enoough stack:
  ResizeStack;
end;

procedure TCPInstructionList.AddBuiltinFunction(Parser: TObject;
  Token: TCPIdentifierToken);
begin
  FInstruction.Kind := tiBuiltinFunction;
  try
    FInstruction.BuiltinFunction := TCPParser(Parser).Functions[Token.Name];
  except
    on ECPKeyNotFoundException do
      raise ECPInvalidExpressionException.Create(ecUnknownFunction,
        TCPTextSequence.Create(Token.Sequence), '');
  end;
end;

procedure TCPInstructionList.AddNumber(Value: Double);
begin
  FInstruction.Kind := tiNumber;
  FInstruction.Value := Value;
end;

procedure TCPInstructionList.AddOperator(Operator: PCPOperator);
begin
  FInstruction.Kind := tiOperator;
  FInstruction.Operation := Operator.Operation;
end;

function TCPInstructionList.AddToken(Parser: TObject; Token: TCPToken)
  : PCPBytecodeInstruction;
begin
  Resize;
  case Token.Kind of
    tkNumber:
      AddNumber(TCPNumberToken(Token).Value);
    tkOperator:
      AddOperator(TCPOperatorToken(Token).Operator);
    tkVariable:
      AddVariable(Parser, TCPIdentifierToken(Token));
    tkBuiltinFunction:
      AddBuiltinFunction(Parser, TCPIdentifierToken(Token));
  end;
  Result := FInstruction;
  Inc(Cardinal(FInstruction), CPInstructionSize);
end;

procedure TCPInstructionList.AddVariable(Parser: TObject;
  Token: TCPIdentifierToken);
var
  Variable: TCPVariable;
  Name: string;
begin
  Name := Token.Name;
  if TCPParser(Parser).Functions.KeyExists(Name) then
    raise ECPInvalidExpressionException.Create(ecInvalidVariableName,
      TCPTextSequence.Create(Token.Sequence), '');

  try
    Variable := TCPParser(Parser).Variables[Name];
  except
    on ECPKeyNotFoundException do
    begin
      Variable := TCPVariable.Create(Name, 0);
      TCPParser(Parser).Variables.Add(Variable);
    end;
  end;
  // Add variable to list of directly referenced variables:
  if FVariables.IndexOf(Variable) = -1 then
    FVariables.Add(Variable);
  FInstruction.Kind := tiVariable;
  FInstruction.Variable := Variable;
end;

procedure TCPInstructionList.AdjustSize;
begin
  SetLength(FBytecode, Cardinal(FInstruction) - Cardinal(FBytecode));
end;

constructor TCPInstructionList.Create(Empty: Boolean = true);
begin
  FVariables := TObjectList.Create(false);
  FStack := CPStack;
  SetLength(FBytecode, CPInstructionSize);
  FInstruction := Pointer(FBytecode);
  FMaxStackCount := -1;
  if not Empty then
  begin
    AddNumber(NaN);
    Inc(Cardinal(FInstruction), CPInstructionSize);
    Finish;
  end;

end;

destructor TCPInstructionList.Destroy;
begin
  FVariables.Free;
  Finalize(FBytecode);
  Finalize(FStack);
  inherited;
end;

{$IFDEF DEBUG}
procedure TCPInstructionList.DumpBytecode;
var
  Instruction: PCPBytecodeInstruction;
  LastInstruction: Cardinal;
begin
  Instruction := Pointer(FBytecode);
  LastInstruction := Cardinal(Instruction) + Cardinal(Length(FBytecode))
    - CPInstructionSize;
  while Cardinal(Instruction) <= Cardinal(LastInstruction) do
  begin
    case TCPInstructionKind(Instruction.Kind) of
      tiNumber:
        Writeln('Num'#9 + FloatToStr(Instruction.Value));
      tiVariable:
        Writeln('Var'#9 + TCPVariable(Instruction.Variable).Name);
      tiBuiltinFunction:
        Writeln(Format('Func'#9'%s (#%d)',
          [Instruction.BuiltinFunction.Name,
           Instruction.ArgumentCount]));
      tiOperator:
        if Instruction.Operation = opNegativeSign then
          Writeln('Op'#9 + '- (Unary)')
        else if Instruction.Operation = opPositiveSign then
          Writeln('Op'#9 + '+ (Unary)')
        else
          Writeln('Op'#9 + CPOperators[Instruction.Operation].Name);
    else
      Writeln('???');
    end;
    Inc(Cardinal(Instruction), CPInstructionSize);
  end;
  Writeln;
end;
{$ENDIF}

function TCPInstructionList.Evaluate: TCPFloat;
var
  Arguments: PCPFloatArray;
  Instruction: PCPBytecodeInstruction;
  StackIndex: Integer;
  LastInstruction: Cardinal;
  A, B: PCPFloat;
begin
  Instruction := Pointer(FBytecode);
  StackIndex := -1;
  LastInstruction := Cardinal(Instruction) + Cardinal(Length(FBytecode))
    - CPInstructionSize;
  while Cardinal(Instruction) <= Cardinal(LastInstruction) do
  begin
    case TCPInstructionKind(Instruction.Kind) of
      tiNumber:
        begin
          Inc(StackIndex);
          CPStack[StackIndex] := Instruction.Value;
        end;
      tiVariable:
        begin
          Inc(StackIndex);
          CPStack[StackIndex] := TCPVariable(Instruction.Variable).Value;
        end;
      tiBuiltinFunction:
        begin
          Dec(StackIndex, Instruction.ArgumentCount - 1);
          Arguments := @(CPStack[StackIndex]);
          CPStack[StackIndex] := Instruction.BuiltinFunction.FunctionPointer
            (Arguments^, Instruction.ArgumentCount);
        end;
      tiOperator:
        begin
          B := @CPStack[StackIndex];
          if Instruction.Operation = opNegativeSign then // Unary operator
            B^ := -B^
          else
          begin
            Dec(StackIndex);
            A := @CPStack[StackIndex];
            case Instruction.Operation of // Binary operators
              opAdd:
                A^ := A^ + B^;
              opSubtract:
                A^ := A^ - B^;
              opMultiply:
                A^ := A^ * B^;
              opDivide:
                A^ := A^ / B^;
              opModulo:
                A^ := A^ - Round(A^ / B^ - 0.5) * B^;
              opPower:
                A^ := Power(A^, B^);
            end;
          end;
        end;
    end;
    Inc(Cardinal(Instruction), CPInstructionSize);
  end;
  Result := CPStack[0];
end;

procedure TCPInstructionList.Finish;
begin
  AdjustSize;
  Validate;
{$IFDEF DEBUGPARSER} DumpBytecode; {$ENDIF}
end;

{ TCPTerm }

constructor TCPTerm.Create(Parser: TObject);
begin
  FParser := Parser;
  Expression := '';
end;

constructor TCPTerm.Create(Parser: TObject; Expression: string);
begin
  Create(Parser);
  SetExpression(Expression);
end;

destructor TCPTerm.Destroy;
begin
  FExpressionError.Free;
  FInstructions.Free;
  inherited;
end;

procedure TCPTerm.SetError(ExpressionError: TCPExpressionError);
begin
  FExpressionError.Free;
  FExpressionError := ExpressionError;
end;

procedure TCPTerm.SetExpression(const Value: string);
var
  AInstructions: TCPInstructionList;
begin
  // Invalidate variables of parser, since variable dependencies may change:
  TCPParser(FParser).Variables.Invalidate;
  if Value = '' then
  begin
    FInstructions.Free;
    FInstructions := TCPInstructionList.Create(false);
{$IFDEF DEBUG}
    FInstructions.DumpBytecode;
{$ENDIF}
  end
  else
  begin
    FExpression := Value;
    try
      { First create a new instruction list then free the old instruction list.
        This prevents variables of old instruction list from getting
        unreferenced, if they are used in the new instruction list as well. }
      AInstructions := TCPParser(FParser).Parse(FExpression);
      FInstructions.Free;
      FInstructions := AInstructions;
      SetError(nil);
    except
      on E: ECPInvalidExpressionException do
      begin
        FInstructions := nil;
        SetError(TCPExpressionError.Create(E));
        raise;
      end;
    end;
  end;
end;

procedure TCPTerm.SetInstructions(const Value: TCPInstructionList);
begin
  if Value <> FInstructions then
  begin
    FInstructions.Free;
    FInstructions := Value;
  end;
end;

initialization

SetLength(CPStack, 64);

finalization

Finalize(CPStack);

end.

